Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue24/ntserv/SvcClass.pas

Pascal/Delphi Source File | 1997-07-04 | 22.9 KB | 637 lines

unit SvcClass;

{ The TNTService class in this unit encapsulates an NT service thread }

interface

uses Classes, Windows, SysUtils, Registry, WinSvcX, MakeMiC, Logging;

type
  PCharArray = ^TCharArray;
  TCharArray = array[0..0] of PChar;

type
  TNTService = class;
  TNTServiceClass = class of TNTService;

  TNTServiceController = class
  private
    FAvailableServices: TList;
    FServiceMainInstance: Pointer;
    function  ProcessOption: DWORD;
    procedure ServiceMain(NumArgs: DWord; Args: PCharArray); StdCall;
    procedure StartService(Name: Shortstring; Parms: TStrings);
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Connect;
    procedure InstallServices(Names: TStrings);
    procedure RegisterService(SvcClass: TNTServiceClass);
    procedure UnInstallServices(Names: TStrings);
  end;

  TNTService = class(TThread)
  private
    FController: TNTServiceController;
    FHandlerInstance: Pointer;
    FNotificationThread: TThread;
    FServiceStatus: TServiceStatus;
    FServicStatusHandle: SERVICE_STATUS_HANDLE;
    procedure DoTerminate; override;
    function GetPaused: Boolean;
    procedure SetCurrentState(Value: DWORD);
    procedure StartNotificationThread;
    procedure TerminateNotificationThread;
  protected
    function AcceptPause: Boolean; virtual;
    function AcceptStop: Boolean; virtual;
    function CanInteract: Boolean; virtual;
    procedure DoHandlerNotification; virtual;
    procedure DoServiceStartup; virtual;
    procedure DoServiceProcessing; virtual; abstract;
    procedure DoServiceCloseDown; virtual;
    procedure Execute; override;
    procedure Handler(Code: Integer); stdcall;
    procedure LogEvent(Severity: DWord; Id: DWord; Inserts: PCharArray; NumInserts: Integer);
    function NeedExtnededElapseTime(Option: DWORD): Boolean; virtual;
    procedure ProcessParms(Parms: TStrings); virtual;
    function WantShutdownNotification: Boolean; virtual;
    property CurrentState: DWORD read FServiceStatus.dwCurrentState write SetCurrentState;
    property Paused: Boolean read GetPaused;
  public
    constructor Create(Parms: TStrings; Controller: TNTServiceController); virtual;
    destructor Destroy; override;
    class procedure DependentServices(List: TStrings); virtual;
    class function ServiceDisplayName: Shortstring; virtual; abstract;
    class function ServiceName: Shortstring; virtual; abstract;
    class function ServiceStartType: DWORD; virtual;
    property Controller: TNTServiceController read FController;
  end;

implementation

const
  EventRegKey = 'SYSTEM\CurrentControlSet\Services\EventLog\Application\';

type
  TNTSCMNotifiyThread = class(TThread)
  private
    FNTService: TNTService;
  protected
    procedure Execute; override;
  public
    constructor Create(Service: TNTService);
  end;

constructor TNTSCMNotifiyThread.Create(Service: TNTService);
begin
  inherited Create(False);
  FNTService := Service;
end;

procedure TNTSCMNotifiyThread.Execute;
var
  OrigStatus: DWORD;

begin
  With FNTService.FServiceStatus do
    begin
      OrigStatus := dwCurrentState;
      dwWaitHint := 5000;
      dwCheckPoint := 0;
    end;
  While not Terminated do
    begin
      MessageBeep(0);
      Sleep(2000);
      With FNTService, FNTService.FServiceStatus do
        if dwCurrentState = OrigStatus then
          begin
            Inc(FServiceStatus.dwCheckPoint);
            SetServiceStatus(FServicStatusHandle,FServiceStatus);
          end;
    end;
end;

{==============================================================================}
{ TNTServiceController                                                         }
{==============================================================================}

Type
  PServiceStartTable = ^TServiceStartTable;
  TServiceStartTable = Array[0..0] Of TServiceTableEntry;

type
  ServNameChar = array[0..255] of char;
  TServNameCharArray = array[0..0] of ServNameChar;
  PServNameCharArray = ^TServNameCharArray;

constructor TNTServiceController.Create;
begin
  inherited Create;
  FAvailableServices := TList.Create;
  FServiceMainInstance := MakeMethodInstance(@TNTServiceController.ServiceMain,Self);
  if FServiceMainInstance = nil then
    Raise Exception.Create('Failed to create method instance for service main');
end;
{------------------------------------------------------------------------------}
destructor TNTServiceController.Destroy;
begin
  FreeMethodInstance(FServiceMainInstance);
  FAvailableServices.Free;
  inherited Destroy;
end;
{------------------------------------------------------------------------------}
procedure TNTServiceController.Connect;
var
  I: Integer;
  ServiceStartTable: PServiceStartTable;
  ServNameArray: PServNameCharArray;

begin
  if FAvailableServices.Count > 0 then
    begin
      ServiceStartTable := AllocMem((FAvailableServices.Count+1)*SizeOf(TServiceTableEntry));
      ServNameArray := AllocMem(FAvailableServices.Count*SizeOf(ServNameChar));
      try
        for I := 0 to FAvailableServices.Count - 1 do
          begin
            StrPCopy(ServNameArray^[I],TNTServiceClass(FAvailableServices[I]).ServiceName);
            ServiceStartTable[I].lpServiceName:= @ServNameArray^[I];
            ServiceStartTable[I].lpServiceProc:= FServiceMainInstance;
          end;
        if not StartServiceCtrlDispatcher(TServiceTableEntry(ServiceStartTable^)) then
          raise Exception.CreateFmt('StartServiceCtrlDispatcher failed with "%d".',[GetLastError]);
      finally
        FreeMem(ServiceStartTable,(FAvailableServices.Count+1)*SizeOf(TServiceTableEntry));
        FreeMem(ServNameArray,FAvailableServices.Count*SizeOf(ServNameChar));
      end;
    end
  else
    raise Exception.Create('No services have been registered to the service controller');
end;
{------------------------------------------------------------------------------}
procedure TNTServiceController.InstallServices(Names: TStrings);
var
  I: Integer;

  procedure DoInstall(Entry: Integer);
  var
    hSCManager: SC_Handle;
    hService: SC_Handle;
    NTService: TNTServiceClass;
    WrkServiceDisplayName: array[0..255] of char;
    WrkServiceName: array[0..255] of char;
    DependencyList: TStrings;
    T: Integer;
    PDepDetails: PChar;
    DepLength: Integer;
    Posn: Integer;
    WStr: string;

    procedure AddEventDetailsToRegistry;
    var
      EventKey: String;

    begin
      WriteLn('Updating registry for event logging');
      EventKey := Format('%s%s',[EventRegKey,NTService.ServiceName]);
      With TRegistry.Create do
       try
         RootKey := HKEY_LOCAL_MACHINE;
         if OpenKey(EventKey,True) then
           try
             WriteInteger('TypesSupported',EVENTLOG_ERROR_TYPE or EVENTLOG_WARNING_TYPE or EVENTLOG_INFORMATION_TYPE);
             WriteString('EventMessageFile',ParamStr(0));
             WriteLn('Registry has been updated for event logging.');
           except
             DeleteKey(EventKey);
             Raise;
           end
         else
           WriteLn(Format('Failed to open key %s',[EventKey]));
       finally
         Free;
       end;
    end;

  begin
    NTService := FAvailableServices[Entry];;
    WriteLn(Format('Installing service %s...',[NTService.ServiceName]));
    DependencyList := TStringlist.Create;
    hSCManager:= OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
    If hSCManager <> 0 then
      try
        NTService.DependentServices(DependencyList);
        if DependencyList.Count > 0 then
          begin
            WriteLn('This service is dependent upon: -');
            DepLength := 1;
            for T := 0 to DependencyList.Count - 1 do
              begin
                WriteLn(' ' + DependencyList[T]);
                Inc(DepLength,Length(DependencyList[T]) + 1);
              end;
            PDepDetails := AllocMem(DepLength);
            Posn := 0;
            for T := 0 to DependencyList.Count - 1 do
              begin
                WStr := DependencyList[T];
                strmove(PDepDetails + Posn,PChar(WStr),Length(WStr));
                Inc(Posn,Length(WStr) + 1);
              end;
          end
        else
          PDepDetails := nil;
        StrPCopy(WrkServiceDisplayName,NTService.ServiceDisplayName);
        StrPCopy(WrkServiceName,NTService.ServiceName);
        hService:= CreateService(hSCManager,WrkServiceName,WrkServiceDisplayName,
                                 SERVICE_ALL_ACCESS,ProcessOption,
                                 NTService.ServiceStartType,SERVICE_ERROR_NORMAL,
                                 PChar(ParamStr(0)),nil,nil,PChar(PDepDetails),nil,nil);
        if Assigned(PDepDetails) then
          FreeMem(PDepDetails,DepLength);
        if hService <> 0 then
          begin
            WriteLn('Service was installed successfully.');
            AddEventDetailsToRegistry;
          end
        else
          WriteLn(Format('Failed to create the service. Error was ''%s''',[SysErrorMessage(GetLastError)]));
      finally
        CloseServiceHandle(hSCManager)
      end
    else
      WriteLn(Format('Failed to open Service Control Manager. Error was ''%s''',[SysErrorMessage(GetLastError)]));
    Dependencylist.Free;
  end;

begin
  if Names.Count = 0 then
    for I := 0 to FAvailableServices.Count - 1 do
      DoInstall(I)
  else
    for I := 0 to FAvailableServices.Count - 1 do
      if Names.IndexOf(UpperCase(TNTServiceClass(FAvailableServices[I]).ServiceName)) <> -1 then
        DoInstall(I);
end;
{------------------------------------------------------------------------------}
{ Sets the value based on the number of registered services.                   }
{ Note: SERVICE_INTERACTIVE_PROCESS is not catered for                         }
function TNTServiceController.ProcessOption: DWORD;
begin
  if FAvailableServices.Count > 1 then
    Result := SERVICE_WIN32_SHARE_PROCESS
  else
    Result := SERVICE_WIN32_OWN_PROCESS;
end;
{------------------------------------------------------------------------------}
{ Adds the class reference to the internal list                                }
procedure TNTServiceController.RegisterService(SvcClass: TNTServiceClass);
begin
  if FAvailableServices.IndexOf(SvcClass) = -1 then
    FAvailableServices.Add(TObject(SvcClass));
end;
{------------------------------------------------------------------------------}
{ This is the entry point for all services in this process. The dispatcher     }
{ created a thread then calls this routine (via the MakeMethodInstance jump    }
{ block.) After the StartService method creates the new thread for the service }
{ this routine terminates thus destroying the thread created by the dispatcher }

{ According to the MSDN this is OK and I haven't found any problems yet.       }
{ However, if this does become a probem you can change StartService to a       }
{ function to return the Thread object. You can then do a Waitfor on that      }
{ object at the end of this method (or do it in the StartService method)       }

Procedure TNTServiceController.ServiceMain(NumArgs: DWord; Args: PCharArray); StdCall;
var
  StartingService: ShortString;
  Parms: TStrings;
  I: Integer;

begin
  StartingService := StrPas(Args^[0]);
  Parms := TStringList.Create;
  try
    for I := 1 to NumArgs - 1 do
      Parms.Add(StrPas(Args^[I]));
    StartService(StartingService,Parms);
  finally
    Parms.Free;
  end;
end;
{------------------------------------------------------------------------------}
{ Creates an instance using the class reference passed to RegisterService      }
procedure TNTServiceController.StartService(Name: Shortstring; Parms: TStrings);
var
  Instance: TNTService;
  I: Integer;

begin
  Instance := nil;
  for I := 0 to FAvailableServices.Count - 1 do
    if TNTServiceClass(FAvailableServices[I]).ServiceName = Name then
      begin
        Instance := TNTService(TNTServiceClass(FAvailableServices[I]).NewInstance);
        try
          Instance.Create(Parms,Self);
          Break;
        except
          Instance.Free;
          Instance := nil;
          break;
        end;
      end;
  if Instance = nil then
    { log failure to start service }
    ;
end;
{------------------------------------------------------------------------------}
procedure TNTServiceController.UnInstallServices(Names: TStrings);
var
  I: Integer;

  procedure DoUnInstall(Entry: Integer);
  var
    hSCManager: SC_Handle;
    hService: SC_Handle;
    NTService: TNTServiceClass;
    WrkServiceName: array[0..255] of char;

    procedure RemoveEventDetailsFromRegistry;
    var
      EventKey: String;

    begin
      WriteLn('Removing event logging registry details.');
      if NTService.ServiceName <> '' then
        begin
          EventKey := Format('%s%s',[EventRegKey,NTService.ServiceName]);
          With TRegistry.Create do
           try
             RootKey := HKEY_LOCAL_MACHINE;
             DeleteKey(EventKey);
             WriteLn('Registry details for event logging has been removed.');
           finally
             Free;
           end;
        end
      else
        WriteLn('Service name missing! Registry not modified.');
    end;

  begin
    NTService := FAvailableServices[Entry];;
    WriteLn(Format('Removing service %s...',[NTService.ServiceName]));
    hSCManager := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
    If hSCManager <> 0 then
      try
        StrPCopy(WrkServiceName,NTService.ServiceName);
        hService := OpenService(hSCManager,WrkServiceName,SERVICE_ALL_ACCESS);
        if hService <> 0 then
          try
            if DeleteService(hService) then
              begin
                WriteLn('Service was uninstalled successfully.');
                RemoveEventDetailsFromRegistry;
              end
            else
              WriteLn(Format('Failed to delete service. Error was ''%s''',[SysErrorMessage(GetLastError)]));
          finally
            CloseServiceHandle(hService);
          end
        else
          WriteLn(Format('Failed to open service "%s": Error was ''%s''',[NTService.ServiceName,SysErrorMessage(GetLastError)]));
      finally
        CloseServiceHandle(hSCManager)
      end
    else
      WriteLn(Format('Failed to open Service control Manager. Error was ''%s''',[SysErrorMessage(GetLastError)]));
  end;

begin
  if Names.Count = 0 then
    for I := 0 to FAvailableServices.Count - 1 do
      DoUnInstall(I)
  else
    for I := 0 to FAvailableServices.Count - 1 do
      if Names.IndexOf(UpperCase(TNTServiceClass(FAvailableServices[I]).ServiceName)) <> -1 then
        DoUnInstall(I);
end;


{==============================================================================}
{ TNTService                                                                   }
{==============================================================================}


{------------------------------------------------------------------------------}
constructor TNTService.Create(Parms: TStrings; Controller: TNTServiceController);
var
  SvcName: array[0..255] of char;

begin
  inherited Create(False);
  FController := Controller;
  FreeOnTerminate := True;
  With FServiceStatus do
    begin
      dwServiceType := FController.ProcessOption;
      if CanInteract then
        dwServiceType := dwServiceType or SERVICE_INTERACTIVE_PROCESS;
    end;
  FHandlerInstance := MakeMethodInstance(@TNTService.Handler,Self);
  if FHandlerInstance = nil then
    Raise Exception.Create('Failed to create method instance for service');
  StrPCopy(SvcName,ServiceName);
  FServicStatusHandle := RegisterServiceCtrlHandler(@SvcName,FHandlerInstance);
  if FServicStatusHandle = 0 then
    Raise Exception.CreateFmt('Failed to register service handler. Code: %d',[GetLastError]);
  ProcessParms(Parms);
end;
{------------------------------------------------------------------------------}
destructor TNTService.Destroy;
begin
  FreeMethodInstance(FHandlerInstance);
  inherited Destroy;
end;
{------------------------------------------------------------------------------}
{ Whether the service can be paused at this time                               }
function TNTService.AcceptPause: Boolean;
begin
  Result := False;
end;
{------------------------------------------------------------------------------}
{ Whether the service can be stopped at this time                              }
function TNTService.AcceptStop: Boolean;
begin
  Result := True;
end;
{------------------------------------------------------------------------------}
{ Can service interact with the desktop - not catered for yet                  }
function TNTService.CanInteract: Boolean;
begin
  Result := False;
end;
{------------------------------------------------------------------------------}
{ Returns a list of all services which need to be started before this service  }
class procedure TNTService.DependentServices(List: TStrings);
begin
end;
{------------------------------------------------------------------------------}
{ When the ControlHandler is called this is executed. It is intended to be     }
{ used for services which wait for objects. If they use MsgWaitFor... this     }
{ method can post a thread message to satisfy the wait                         }
procedure TNTService.DoHandlerNotification;
begin
end;
{------------------------------------------------------------------------------}
{ Any service initialisation here                                              }
procedure TNTService.DoServiceStartup;
begin
end;
{------------------------------------------------------------------------------}
{ Any service closedown here                                                   }
procedure TNTService.DoServiceCloseDown;
begin
end;
{------------------------------------------------------------------------------}
procedure TNTService.DoTerminate;
begin
  inherited DoTerminate;
  DoServiceCloseDown;
  CurrentState := SERVICE_STOPPED;
end;
{------------------------------------------------------------------------------}
procedure TNTService.Execute;
begin
  CurrentState := SERVICE_START_PENDING;
  DoServiceStartup;
  CurrentState := SERVICE_RUNNING;
  DoServiceProcessing;
end;
{------------------------------------------------------------------------------}
function TNTService.GetPaused: Boolean;
begin
  Result := (CurrentState = SERVICE_PAUSED);
end;
{------------------------------------------------------------------------------}
{ The handler called by the dispatcher. The CurrentState property write method }
{ creates a second thread if the state transition is going to be lengthy       }
procedure TNTService.Handler(Code: Integer); StdCall;
begin
  case Code of
    SERVICE_CONTROL_STOP,SERVICE_CONTROL_SHUTDOWN:
      begin
        CurrentState := SERVICE_STOP_PENDING;
        Terminate;
      end;
    SERVICE_CONTROL_PAUSE:
      begin
        CurrentState := SERVICE_PAUSE_PENDING;
      end;
    SERVICE_CONTROL_CONTINUE:
      begin
        CurrentState := SERVICE_CONTINUE_PENDING;
      end;
    SERVICE_CONTROL_INTERROGATE:
      begin
        CurrentState := FServiceStatus.dwCurrentState;
      end;
  end;
  DoHandlerNotification;
end;
{------------------------------------------------------------------------------}
procedure TNTService.LogEvent(Severity: DWord; Id: DWord; Inserts: PCharArray; NumInserts: Integer);
var
  SvcNameChar: Array[0..255] of char;
  EventSource: THandle;

begin
  StrPCopy(SvcNameChar,ServiceName);
  EventSource := RegisterEventSource(nil,@SvcNameChar);
  try
    ReportEvent(EventSource,Severity,0,Id,nil,NumInserts,0,PChar(Inserts^),nil);
  finally
    DeRegisterEventSource(EventSource);
  end;
end;
{------------------------------------------------------------------------------}
{ The thread created here is responsible for updatibg the SCM                  }
procedure TNTService.StartNotificationThread;
begin
  if not Assigned(FNotificationThread) then
    FNotificationThread := TNTSCMNotifiyThread.Create(Self);
end;
{------------------------------------------------------------------------------}
{ Stops the secondary thread.                                                  }
procedure TNTService.TerminateNotificationThread;
begin
  if Assigned(FNotificationThread) then
    begin
      FNotificationThread.Terminate;
      FNotificationThread.WaitFor;
      FNotificationThread := nil;
    end;
end;
{------------------------------------------------------------------------------}
{ When overriden this function should return True if the operation (passed as  }
{ the Option parameter) is going to take quite a few seconds.                  }
function TNTService.NeedExtnededElapseTime(Option: DWORD): Boolean;
begin
  Result := False;
end;
{------------------------------------------------------------------------------}
{ This is called by the constructor and the Parms contain any parameters types }
{ by the user in the services control panel applet.                            }
procedure TNTService.ProcessParms(Parms: TStrings);
begin
end;
{------------------------------------------------------------------------------}
{ This can be overridden to alter when the service is started. For services    }
{ this can only be demand, auto or disabled.                                   }
class function TNTService.ServiceStartType: DWORD;
begin
  Result := SERVICE_DEMAND_START;
end;
{------------------------------------------------------------------------------}
{ This is the write property access routine for the CurrentState property.     }
{ The FServiceStatus is updated and SetServiceStatus is called to inform the   }
{ SCM. For all the PENDING states a NotificationThread is created if the       }
{ NeedExtnededElapseTime returns True. When the STOP/RUNNING or PAUSED states  }
{ are set the notification thread is terminated (if applicable).               }
procedure TNTService.SetCurrentState(Value: DWORD);
begin
  With FServiceStatus do
    begin
      dwCurrentState := Value;
      dwControlsAccepted := 0;
      if AcceptStop then
        dwControlsAccepted := SERVICE_ACCEPT_STOP;
      if AcceptPause then
        dwControlsAccepted := dwControlsAccepted or SERVICE_ACCEPT_PAUSE_CONTINUE;
      if WantShutdownNotification then
        dwControlsAccepted := dwControlsAccepted or SERVICE_ACCEPT_SHUTDOWN;
    end;
  SetServiceStatus(FServicStatusHandle,FServiceStatus);
  case Value of
    SERVICE_STOPPED,SERVICE_RUNNING,SERVICE_PAUSED:
      begin
        TerminateNotificationThread;
      end;
    SERVICE_START_PENDING,SERVICE_STOP_PENDING,SERVICE_CONTINUE_PENDING,SERVICE_PAUSE_PENDING:
      begin
        if NeedExtnededElapseTime(Value) then
          StartNotificationThread;
      end;
  end;
end;
{------------------------------------------------------------------------------}
function TNTService.WantShutdownNotification: Boolean;
begin
  Result := False;
end;

end.